home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / prim / toolbar.el.z / toolbar.el
Encoding:
Text File  |  1998-05-21  |  5.9 KB  |  164 lines
  1. ;;; toolbar.el --- Toolbar support for XEmacs
  2.  
  3. ;; Copyright (C) 1995, 1997 Free Software Foundation, Inc.
  4.  
  5. ;; Maintainer: XEmacs Development Team
  6. ;; Keywords: extensions, internal
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  22. ;; Free Software Foundation, 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Synched up with: Not in FSF.
  26.  
  27. ;;; Commentary:
  28.  
  29. ;;; Code:
  30.  
  31. (defvar toolbar-help-enabled t
  32.   "If non-nil help is echoed for toolbar buttons.")
  33.  
  34. (defvar toolbar-icon-directory nil
  35.   "Location of standard toolbar icon bitmaps.")
  36.  
  37. (defun toolbar-make-button-list (up &optional down disabled cap-up cap-down cap-disabled)
  38.   "Calls make-glyph on each arg and returns a list of the results."
  39.   (if (featurep 'x)
  40.       (let ((up-glyph (make-glyph up))
  41.         (down-glyph (and down (make-glyph down)))
  42.         (disabled-glyph (and disabled (make-glyph disabled)))
  43.         (cap-up-glyph (and cap-up (make-glyph cap-up)))
  44.         (cap-down-glyph (and cap-down (make-glyph cap-down)))
  45.         (cap-disabled-glyph (and cap-disabled (make-glyph cap-disabled))))
  46.     (if cap-disabled
  47.         (list up-glyph down-glyph disabled-glyph
  48.           cap-up-glyph cap-down-glyph cap-disabled-glyph)
  49.       (if cap-down
  50.         (list up-glyph down-glyph disabled-glyph
  51.           cap-up-glyph cap-down-glyph)
  52.         (if cap-up
  53.         (list up-glyph down-glyph disabled-glyph cap-up-glyph)
  54.           (if disabled-glyph
  55.           (list up-glyph down-glyph disabled-glyph)
  56.         (if down-glyph
  57.             (list up-glyph down-glyph)
  58.           (list up-glyph)))))))
  59.     nil))
  60.  
  61. (defun init-toolbar-location ()
  62.   (if (not toolbar-icon-directory)
  63.       (setq toolbar-icon-directory
  64.         (file-name-as-directory
  65.          (expand-file-name "toolbar" data-directory)))))
  66.  
  67. (defun init-toolbar-from-resources (locale)
  68.   (if (and (featurep 'x)
  69.        (or (eq locale 'global)
  70.            (eq 'x (device-or-frame-type locale))))
  71.       (x-init-toolbar-from-resources locale)))
  72.  
  73.  
  74. ;; #### Is this actually needed or will the code in
  75. ;; default-mouse-motion-handler suffice?
  76. (define-key global-map 'button1up 'release-toolbar-button)
  77.  
  78. (defvar toolbar-map (let ((m (make-sparse-keymap)))
  79.               (set-keymap-name m 'toolbar-map)
  80.               m)
  81.   "Keymap consulted for mouse-clicks over a toolbar.")
  82.  
  83. (define-key toolbar-map 'button1 'press-toolbar-button)
  84. (define-key toolbar-map 'button1up 'release-and-activate-toolbar-button)
  85. (defvar last-pressed-toolbar-button nil)
  86. (defvar toolbar-active nil)
  87.  
  88. ;;
  89. ;; It really sucks that we also have to tie onto
  90. ;; default-mouse-motion-handler to make sliding buttons work right.
  91. ;;
  92. (defun press-toolbar-button (event)
  93.   "Press a toolbar button.  This only changes its appearance.
  94. Call function stored in `toolbar-blank-press-function,' if any, with EVENT as
  95. an argument if press is over a blank area of the toolbar."
  96.   (interactive "_e")
  97.   (setq this-command last-command)
  98.   (let ((button (event-toolbar-button event)))
  99.     ;; We silently ignore non-buttons.  This most likely means we are
  100.     ;; over a blank part of the toolbar.
  101.     (setq toolbar-active t)
  102.     (if (toolbar-button-p button)
  103.     (progn
  104.       (set-toolbar-button-down-flag button t)
  105.       (setq last-pressed-toolbar-button button))
  106.       ;; Added by Bob Weiner, Motorola Inc., 10/6/95, to handle
  107.       ;; presses on blank portions of toolbars.
  108.       (and (boundp 'toolbar-blank-press-function)
  109.        (functionp toolbar-blank-press-function)
  110.        (funcall toolbar-blank-press-function event)))))
  111.  
  112. (defun release-and-activate-toolbar-button (event)
  113.   "Release a toolbar button and activate its callback.
  114. Call function stored in `toolbar-blank-release-function,' if any, with EVENT
  115. as an argument if release is over a blank area of the toolbar."
  116.   (interactive "_e")
  117.   (or (button-release-event-p event)
  118.       (error "%s must be invoked by a mouse-release" this-command))
  119.   (release-toolbar-button event)
  120.   (let ((button (event-toolbar-button event)))
  121.     (if (and (toolbar-button-p button)
  122.          (toolbar-button-enabled-p button)
  123.          (toolbar-button-callback button))
  124.     (let ((callback (toolbar-button-callback button)))
  125.       (setq this-command callback)
  126.       ;; Handle arbitrary functions.
  127.       (if (functionp callback)
  128.           (if (commandp callback)
  129.           (call-interactively callback)
  130.         (funcall callback))
  131.         (eval callback))))))
  132.  
  133. ;; If current is not t, then only release the toolbar button stored in
  134. ;; last-pressed-toolbar-button
  135. (defun release-toolbar-button-internal (event current)
  136.   (let ((button (event-toolbar-button event)))
  137.     (setq zmacs-region-stays t)
  138.     (if (and last-pressed-toolbar-button
  139.          (not (eq last-pressed-toolbar-button button))
  140.          (toolbar-button-p last-pressed-toolbar-button))
  141.     (progn
  142.       (set-toolbar-button-down-flag last-pressed-toolbar-button nil)
  143.       (setq last-pressed-toolbar-button nil)))
  144.     (if (and current (toolbar-button-p button))
  145.     (set-toolbar-button-down-flag button nil))))
  146.  
  147. (defun release-toolbar-button (event)
  148.   "Release all pressed toolbar buttons."
  149.   (interactive "_e")
  150.   (or (button-release-event-p event)
  151.       (error "%s must be invoked by a mouse-release" this-command))
  152.   (release-toolbar-button-internal event t)
  153.   ;; Don't set this-command if we're being called
  154.   ;; from release-and-activate-toolbar-button.
  155.   (if (interactive-p)
  156.       (setq this-command last-command))
  157.   (setq toolbar-active nil))
  158.  
  159. (defun release-previous-toolbar-button (event)
  160.   (setq zmacs-region-stays t)
  161.   (release-toolbar-button-internal event nil))
  162.  
  163. ;;; toolbar.el ends here
  164.